home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / Toolbox classes / Scroller < prev    next >
Text File  |  1998-12-01  |  16KB  |  519 lines
  1. \ Scroller - view which supports scroll bars.
  2.  
  3. \ May 91    mrh    Added horizontal scroll bar support.
  4. \ Oct 91    mrh    Changed owner from Window to View.  Replaces vscroll 
  5. \ May 92    mrh    Changed to "new-style" control.
  6. \ June 92    mrh    Fixed GetRect: in Scroller.
  7. \ Feb 93    mrh Introduced class BigRect for PanRects, to allow humungous rects.
  8. \ Sept 93    mrh    Revised for new control scheme - controls now a view subclass.
  9. \ Nov95        JRF    now properly hiding and showing scrollbars
  10. \ Oct96        mrh fixed SetPanRanges: in line with the above
  11.  
  12. need    view
  13. need    ctl
  14.  
  15. (*
  16. SCROLLER is a view which has support for a vertical and horizontal
  17. scroll bar along the right hand and bottom edge respectively.  We implement
  18. it with three child views: mainView, which is the display area, and the
  19. two scroll bars themselves.
  20.  
  21. MainView is an instance of a one-off class, Mview.  This class has a
  22. rectangle, PanRect, which normally ought to enclose all the child views
  23. of the Mview.  The usual scenario is that PanRect is larger than the viewRect,
  24. and scrolling amounts to shifting the child views (and PanRect) around within
  25. the viewRect - which, from another point of view, can be thought of as
  26. "panning" the viewRect over the PanRect area.
  27.  
  28. Mview has appropriate methods for returning the distances by which PanRect
  29. falls outside the viewRect area, so that the parent Scroller can set the
  30. scroll bar values appropriately.
  31.  
  32. One unusual thing we do here is to override addView: on Scroller so that it
  33. becomes an ADDVIEW: on MainView, since this is usually what we really mean.
  34. In the case where you want to really addView: on the Scroller, such as to add
  35. another child view alongside one of the scroll bars, you should subclass
  36. Scroller with the extra views as ivars, and at run time do addView: super
  37. as we do for the scroll bars (see the NEW: method).
  38.  
  39. Another approach we could have taken to implementing MainView would have been
  40. as a pointer, with late binding.  That way MainView could have been any
  41. view subclass.  That would have been more flexible, but possibly overkill
  42. for what we usually want to do - it would have required a more complex
  43. setting-up process, with the MainView address having to be passed in after
  44. NEW: has been done.  But if you need the extra flexibility, feel free to clone
  45. Scroller and make the changes!
  46.  
  47. PanRect can obviously be very big, so we don't implement it as a regular rect,
  48. but define a new class, BigRect, which uses vars rather than ints for the
  49. coordinates.
  50. *)
  51.  
  52. PPC? not
  53. [IF]
  54. nilP    value    ClickedScroller
  55. [THEN]
  56.                 \ CLICK: on a Scroller puts the Scroller's addr here, so
  57.                 \ child views can easily send messages back to the clicked
  58.                 \ Scroller.  Scroll bars use this, also TextEdit views.
  59.                 \ I could have just used ThisCtl, but if another control
  60.                 \ is involved somewhere it might get clobbered.  Unlikely,
  61.                 \ but I'm a cautious individual.
  62.                 
  63.                 \ On the PPC, this is in zObjInit since we can't have
  64.                 \ :ppc_proc  in modules.
  65.  
  66.  
  67. : 1R    1Right:        [ clickedScroller ]  ;
  68. : 1L    1Left:        [ clickedScroller ]  ;
  69. : 1U    1Up:        [ clickedScroller ]  ;
  70. : 1D    1Down:        [ clickedScroller ]  ;
  71.  
  72. : PGR    pgRight:    [ clickedScroller ]  ;
  73. : PGL    pgLeft:        [ clickedScroller ]  ;
  74. : PGU    pgUp:        [ clickedScroller ]  ;
  75. : PGD    pgDown:        [ clickedScroller ]  ;
  76.  
  77. : VD    Vdrag:        [ clickedScroller ]  ;
  78. : HD    Hdrag:        [ clickedScroller ]  ;
  79.  
  80.  
  81.  
  82.  
  83. \            ================= BigRect ===================
  84.  
  85. \ BIGRECT is exactly that -- using vars rather than ints for the
  86. \ coordinates.  The toolbox doesn't support this, so we just use
  87. \ it in places where we need very big rectangles and control
  88. \ everything ourselves.  So far we only need to support GET:, PUT:
  89. \ and SHIFT: methods.
  90.  
  91. :class  BIGRECT  super{ object }
  92. record
  93. {    var        TOP
  94.     var        LEFT
  95.     var        BOTTOM
  96.     var        RIGHT
  97. }
  98.  
  99. :m GET:        get: left  get: top  get: right  get: bottom  ;m
  100. :m PUT:        put: bottom  put: right  put: top  put: left  ;m
  101.  
  102. :m SHIFT:  { dx dy -- }
  103.     dx dy or  0EXIT
  104.     dx +: left  dx +: right
  105.     dy +: top   dy +: bottom  ;m
  106.     
  107. :m INSET:  { dx dy -- }
  108.     dx +: left  dx -: right
  109.     dy +: top   dy -: bottom  ;m
  110.  
  111. ;class
  112.  
  113.  
  114. \            ================= Mview ===================
  115.  
  116. \ MVIEW is a view which we use for the main view of a Scroller (the view
  117. \ with the actual contents - the other two views are the two scroll
  118. \ bars).  It has methods to shift its children, or, depending on
  119. \ the point of view, "panning" over the children.
  120.  
  121.  
  122. :class  MVIEW  super{ view }
  123. record
  124. {    bigrect        PANRECT        \ Rect for "panning" children.  Ought to
  125.                             \  contain all of them.  Can be enormous.
  126. }
  127.  
  128. :m ^panRect:    addr: panRect  ;m
  129.  
  130. :m GETPANRECT:
  131.     get: panRect  ;m
  132.     
  133. :m PUTPANRECT:
  134.     put: panRect  ;m
  135.  
  136.  
  137. \ SHIFTCHILDREN ( dx dy -- )  moves all the child views by
  138. \ the given distance.  We do this by changing their bounds appropriately
  139. \ then calling MOVED:.
  140.  
  141. :m SHIFTCHILDREN:  { dx dy \ theChild l t r b -- }
  142.     BEGIN  each: children
  143.     WHILE
  144.         -> theChild
  145.         theChild getBounds: view  -> b  -> r  -> t  -> l
  146.         dx ++> l  dx ++> r
  147.         dy ++> t  dy ++> b
  148.         l t r b  theChild  setBounds: class_as> view
  149.         moved: [ theChild ]        \ late bind here as different things may happen
  150.     REPEAT  ;m
  151.  
  152.  
  153. \ CoercePanRect: shifts the children so that panRect falls as far
  154. \ within the viewRect as possible.  We factor out (CoercePanRect):
  155. \ which does the basic stuff that Scroller subclasses can use.
  156.  
  157. private
  158. :m HowFar:  { offs1 offs2 -- offs' }
  159.     offs1 offs2 xor 0>                    \ Same sign?
  160.     IF        offs1  offs2 dup 0<
  161.             IF  max  ELSE  min  THEN
  162.     ELSE    0
  163.     THEN  ;m
  164.  
  165. public
  166.  
  167. :m (CoercePanRect):  { \ pLeft pTop pRt pBot dx dy -- dx dy  }
  168.     \ Returns the amount we have to shift panRect to get it into
  169.     \ the right position.  We pass in panRect's coordinates so that
  170.     \ Scroller subclasses can use a different panRect (TEScroller
  171.     \ does this).
  172.     
  173.     get: panRect  -> pBot -> pRt -> pTop -> pLeft
  174.     getTopX: viewRect  pLeft -
  175.     getBotX: viewRect  pRt   -   howFar: self  -> dx
  176.     getTopY: viewRect  pTop  -
  177.     getBotY: viewRect  pBot  -   howFar: self  -> dy
  178.     dx dy shift: panRect
  179.     dx  dy  ;m
  180.     
  181.  
  182. :m CoercePanRect:  { \ dx dy -- }
  183.     (coercePanRect): self  -> dy  -> dx
  184.     dx dy or  0EXIT
  185.     dx dy  shiftChildren: self  ;m
  186.  
  187.  
  188. \ Here we define the default panRect to be the rect which just contains
  189. \ all the child views.  Change as necessary.
  190.  
  191. :m DfltPanRect:  { \ left top rt bot -- }
  192.     first?: children
  193.     NIF        0 -> bot  0 -> rt  0 -> top  0 -> left
  194.     ELSE    getRect: []  -> bot  -> rt  -> top  -> left
  195.     THEN
  196.     BEGIN    each: children
  197.     WHILE    getRect: []
  198.         bot max -> bot    rt max -> rt
  199.         top min -> top  left min -> left
  200.     REPEAT
  201.     left top rt bot  put: panRect  ;m
  202.  
  203. :m CLASSINIT:
  204.     classinit: super  set: canHaveFocus?  ;m
  205.  
  206. ;class
  207.  
  208.  
  209.  
  210. \            ================= Scroller ===================
  211.  
  212. \ SCROLLER is a view which has support for a vertical and horizontal
  213. \ scroll bar along the right hand and bottom edge respectively.
  214. \ Either may be present or absent, and may have an offset or gap
  215. \ at either end of a specified amount.
  216.  
  217. :class    SCROLLER  super{ view }
  218.  
  219.     mview    MainView        \ The display area, minus the scroll bars
  220.     vscroll    TheVscroll
  221.     hscroll    TheHscroll
  222.  
  223. record
  224. {    bool    vscroll?        \ True if v scroll bar to be used
  225.     bool    hscroll?        \ True if h scroll bar to be used
  226.     bool    UsePanRect?        \ True if we're to use PanRect
  227.  
  228.     var        HPAN            \ Horizontal panning range
  229.     var        HPOS            \ Current vertical posn
  230.     var        VPAN            \ Vertical ditto
  231.     var        VPOS
  232.  
  233.     int        HUNIT            \ # pixels for one horizontal arrow click
  234.     int        VUNIT
  235.     
  236.     int        Lgap            \ The "gaps" at the ends of the scroll bars
  237.     int        Tgap            \ (normally zero, but can be specified)
  238.     int        Rgap
  239.     int        Bgap
  240. }
  241.  
  242. :m SetPanRanges:  { \ left top rt bot pLeft pTop pRt pBot -- }
  243.     getViewRect: mainView  -> bot  -> rt  -> top  -> left
  244.     getPanRect: mainView  -> pBot  -> pRt  -> pTop  -> pLeft
  245.     left pLeft -  dup  0 max  put: Hpos
  246.     pRt rt -  +  0  max  put: Hpan
  247.     top pTop -  dup  0 max  put: Vpos
  248.     pBot bot -  +  0 max  put: Vpan
  249.  
  250.     noClip        \ seems we need one before setting each scroll bar
  251.     get: vscroll?
  252.     IF    0  get: vpan  putRange: theVscroll
  253.         get: vpan
  254.         IF    get: vpos  put: theVscroll
  255.             get: enabled? IF  enable: theVscroll  THEN        \ Oct96 mrh
  256.         ELSE
  257.             0 put: theVscroll
  258.             disable: theVscroll
  259.         THEN
  260.     THEN
  261.  
  262.     noClip
  263.     get: hscroll?
  264.     IF    0  get: hpan  putRange: theHscroll
  265.         get: hpan
  266.         IF    get: hpos  put: theHscroll
  267.             get: enabled? IF  enable: theHscroll  THEN        \ Oct96 mrh
  268.         ELSE
  269.             0 put: theHscroll
  270.             disable: theHscroll
  271.         THEN
  272.     THEN
  273. ;m
  274.  
  275.  
  276. :m FixPanRect:
  277.     get: usePanRect?  NIF  dfltPanRect: mainView  THEN
  278.     coercePanRect: mainView
  279.     setPanRanges: self  ;m
  280.  
  281.  
  282. :m FixMainViewBounds:
  283.     getBounds: mainView  2drop        \ Don't change left or top
  284.     -16 get: vscroll? and  -16 get: hscroll? and
  285.     setBounds: mainView  ;m
  286.  
  287.  
  288. :m FixHscrollBounds:
  289.     -1 get: Lgap +                        \ left
  290.     -16                                    \ top
  291. \    -15 get: vscroll? and  get: Rgap -    \ right
  292.     get: vscroll? IF  -15  ELSE  1  THEN
  293.     get: Rgap -                            \ right        -mrh 13-mar-07
  294.     0                                    \ bottom
  295.     setBounds: theHscroll  moved: theHscroll  ;m
  296.  
  297. :m FixVscrollBounds:
  298.     -16                                    \ left
  299.     -1  get: Tgap +                        \ top
  300.     0                                    \ right
  301. \    -15 get: hscroll? and  get: Bgap -  \ bottom
  302.     get: hscroll? IF  -15  ELSE  1  THEN
  303.     get: Bgap -                          \ bottom    -mrh 13-mar-07
  304.     setBounds: theVscroll  moved: theVscroll  ;m
  305.  
  306. public
  307.  
  308.  
  309. ( b -- )
  310. :m VSCROLL:     put: vscroll?  fixMainViewBounds: self  ;m
  311. :m HSCROLL:     put: hscroll?  fixMainViewBounds: self  ;m
  312.  
  313.  
  314. :m PUTPANRECT:  ( l t r b -- )
  315.     putPanRect: mainView  true put: usePanRect?
  316.     coercePanRect: mainView  setPanRanges: self  ;m
  317.  
  318. \ addview: needs to add the child view to mainView, not to
  319. \  the Scroller itself.
  320.  
  321. :m ADDVIEW:        addView: mainView  ;m
  322.  
  323. ( n -- )
  324. :m >HUNIT:    put: Hunit  ;m
  325. :m >VUNIT:    put: Vunit  ;m
  326.  
  327. :m >VRANGE:    putRange: theVscroll  ;m
  328. :m >HRANGE:    putRange: theHscroll  ;m
  329.  
  330. :m >GAPS:    ( l t r b -- )
  331.     put: Bgap  put: Rgap  put: Tgap  put: Lgap
  332. ;m
  333.  
  334. :m ?VENABLE:
  335.     get: vscroll?  0EXIT
  336.     show: theVscroll    \ Nov95 JRF now properly hiding and showing scrollbars
  337.     get: Vpan  0EXIT
  338.     enable: theVscroll  ;m
  339.  
  340. :m ?HENABLE:
  341.     get: hscroll?  0EXIT
  342.     show: theHscroll    \ Nov95 JRF
  343.     get: Hpan  0EXIT
  344.     enable: theHscroll  ;m
  345.  
  346.  
  347. :m NEW:        \ mainView and the 2 scroll bars are ivars, but they have to be
  348.             \  children as well!
  349.     addr: mainView        addView: super
  350.     get: hscroll?  IF  addr: theHscroll  addView: super  THEN
  351.     get: vscroll?  IF  addr: theVscroll  addView: super  THEN
  352.     new: super
  353.     get: lastSibRect
  354.     fixHscrollBounds: self  fixVscrollBounds: self
  355.     fixPanRect: self
  356.     put: lastSibRect  ;m
  357.  
  358.  
  359. :m ENABLE:
  360.     get: alive?  0EXIT
  361.     ?Venable: self  ?Henable: self
  362.     enable: super  ;m
  363.  
  364. :m DISABLE:
  365.     get: alive?  0EXIT
  366.     get: vscroll?  if  disable: theVscroll  hide: theVscroll then    \ JRF
  367.     get: hscroll?  if  disable: theHscroll  hide: theHscroll then    \ JRF
  368.     disable: super  ;m
  369.  
  370.  
  371. :m MOVED:
  372.     moved: super
  373.     fixPanRect: self
  374.     update: self  ;m
  375.  
  376.  
  377.  
  378. (*    PAN: ( dx dy -- )  pans the view over the subviews by the given distance.
  379.     Doesn't alter the scroll bars -- use PANRIGHT: etc. for this, since they
  380.     adjust the appropriate scroll bar and then call PAN:.
  381.  
  382.     Our convention is that positive dx and dy correspond to a pan to the
  383.     right and down, which means that the subviews are being shifted to the
  384.     left and up, which is a "negative" shift.  It's very easy to get this
  385.     mixed up, but it would be just as confusing if I did it the other way
  386.     around.  If something doesn't work, try reversing the signs!!
  387.  
  388.     Another point to note is that I've found by experimentation that if
  389.     the mouse is held down in a scroll bar arrow, our arrow routine, which
  390.     is passed to TrackControl as a proc, gets called continually -- thus we
  391.     can't handle an update event on the window are until mouse-up.  I'm not
  392.     even sure there is an update event until then, anyway.
  393.     I guess Apple's idea is that each time the origin should get
  394.     shifted, so that the little rectangles which are invalidated each time
  395.     get accumulated properly.  But in our way of doing things, we're using
  396.     the grafport origin all the time (until a DRAW: is done), so the same
  397.     rectangle would get invalidated repeatedly.  So we handle this with an
  398.     ivar, #updates.  If we get a PAN: call and #updates is zero, we call
  399.     InvalRect as normal.  If #updates is 1, the little rectangle will already
  400.     be invalid, but rather than trying to invalidate an adjacent rectangle
  401.     we take the easy way out and invalidate the whole viewRect.  At least
  402.     that way we can be sure we don't miss updating something.  If #updates
  403.     is greater than 2, we've already invalidated the viewRect, so there's
  404.     nothing left to do -- so that's exactly what we do.
  405.  
  406.     Another point that has come out through experimentation is that the
  407.     scroll bar which has had its arrow clicked must not be clipped out, or
  408.     the thumb isn't redrawn in the right position.  The redraw is done by
  409.     the system, but mustn't be clipped out.  So we set the clip to the right
  410.     contents area with ClipRect, scroll the rectangle, then at the end set
  411.     the clip to the rect containing the appropriate scroll bar so that the
  412.     system will redraw it properly. 
  413. *)
  414.  
  415.  
  416. :m PAN:  { dx dy \ #upd hext vext -- }
  417.     dx  +: hpos  dy +: vpos
  418.     neg> dx  neg> dy
  419.     ^viewRect: mainView  dup  ClipRect
  420.     dx dy theRgn  ScrollRect
  421.     get: #updates  -> #upd  #upd 1+ 100 min  put: #updates
  422.     #upd
  423.     NIF        theRgn  InvalRgn  false put: setClip?
  424.     ELSE    #upd 1 = IF  ^viewRect: mainView  InvalRect  THEN
  425.     THEN
  426.     dx dy  shiftChildren: mainView
  427.     noClip  ;m
  428.     
  429. \ Note: it turns out we need the noClip so that the scroll bar arrow
  430. \ always unhilites.
  431.     
  432.  
  433. :m PANRIGHT:  { dx \ hs -- }
  434.     get: theHscroll  -> hs
  435.     hs dx +  get: Hpan  >
  436.     IF  get: Hpan  hs -  -> dx  THEN
  437.     dx  0EXIT
  438.     hs dx +  put: theHscroll
  439.     dx  0  pan: [self]  ;m
  440.  
  441. :m PANLEFT:  { dx \ hs -- }
  442.     get: theHscroll  -> hs   hs 0EXIT
  443.     hs dx -  0< if  hs -> dx  then
  444.     hs dx -  put: theHscroll
  445.     dx negate  0  pan: [self]  ;m
  446.  
  447. :m PANDOWN:  { dy \ vs -- }
  448.     get: theVscroll  -> vs
  449.     vs dy +  get: Vpan  >
  450.     IF  get: Vpan  vs -  -> dy  THEN
  451.     dy  0EXIT
  452.     vs dy +  put: theVscroll
  453.     0  dy  pan: [self]  ;m
  454.  
  455. :m PANUP:  { dy \ vs -- }
  456.     get: theVscroll  -> vs   vs 0EXIT
  457.     vs dy - 0<  IF  vs -> dy  THEN
  458.     vs dy -  put: theVscroll
  459.     0  dy negate  pan: [self]  ;m
  460.  
  461.  
  462. :m HPAGE:  { \ left top rt bot -- #pixels }
  463.     get: viewRect  -> bot  -> rt  -> top  -> left
  464.     rt left -  get: Hunit -  0 max  ;m
  465.  
  466. :m VPAGE:  { \ left top rt bot -- #pixels }
  467.     get: viewRect  -> bot  -> rt  -> top  -> left
  468.     bot top -  get: Vunit -  0 max  ;m
  469.  
  470. :m 1RIGHT:    get: Hunit  panRight: [self]  ;m
  471. :m 1LEFT:    get: Hunit  panLeft: [self]   ;m
  472. :m 1UP:        get: Vunit  panUp: [self]     ;m
  473. :m 1DOWN:    get: Vunit  panDown: [self]   ;m
  474.  
  475. :m PGRIGHT:    hPage: self  panRight: [self]    ;m
  476. :m PGLEFT:    hPage: self  panLeft: [self]    ;m
  477. :m PGUP:    vPage: self  panUp: [self]        ;m
  478. :m PGDOWN:    vPage: self  panDown: [self]    ;m
  479.  
  480. :m VDRAG:    0  get: theVscroll  get: vpos -  pan: [self]  ;m
  481. :m HDRAG:    get: theHscroll  get: hpos -  0  pan: [self]  ;m
  482.     
  483.  
  484. (*    The view_for_click?: method only has to do one extra thing over what View
  485.     provides - we put the addr of this Scroller in clickedScroller so the
  486.     scroll bar action handlers can send messages back to us.
  487.     Note, we have to do this first, even if we don't want the click, since
  488.     click: super may call the action handler, which will rely on it being set.
  489.     But this will be harmless if we don't want the click, since any other
  490.     scroller that wants the click will reset the value before it uses it.
  491.     Then when we see that we want the click, we have to set clickedScroller
  492.     again, since calling click: super may have changed it.
  493. *)
  494.  
  495. :m view_for_click?:  ( -- ^view T | -- F )
  496.     ^base -> clickedScroller
  497.     view_for_click?: super
  498. ;m
  499.  
  500.  
  501. :m CLASSINIT:
  502.     classinit: super
  503.     true  vscroll: self   true  hscroll: self        \ Defaults
  504.  
  505.     4 dup  put: Hunit  put: Vunit
  506.  
  507.     XTS{ 1l 1r pgl pgr hd }                    actions: theHscroll
  508.     XTS{ 1u 1d pgu pgd vd }                    actions: theVscroll
  509.     parRight parTop parRight parBottom        setJust: theVscroll
  510.     parLeft parBottom parRight parBottom    setJust: theHscroll
  511.  
  512.     parLeft parTop parRight parBottom        setJust: mainView
  513. ;m
  514.  
  515. ;class
  516.  
  517.  
  518. endload
  519.